home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpcsrc.lha / fpc / compiler / pstatmnt.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  41KB  |  1,183 lines
  1. {
  2.     $Id: pstatmnt.pas,v 1.3.2.1 1998/08/05 14:07:34 pierre Exp $
  3.     Copyright (c) 1998 by Florian Klaempfl
  4.  
  5.     Does the parsing of the statements
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit pstatmnt;
  24.  
  25.   interface
  26.  
  27.     uses tree;
  28.  
  29.     var
  30.        { true, if we are in a except block }
  31.        in_except_block : boolean;
  32.  
  33.     { reads a block }
  34.     function block(islibrary : boolean) : ptree;
  35.  
  36.     { reads an assembler block }
  37.     function assembler_block : ptree;
  38.  
  39.   implementation
  40.  
  41.     uses
  42.        cobjects,scanner,globals,symtable,aasm,pass_1,
  43.        types,hcodegen,files,verbose
  44.        { processor specific stuff }
  45. {$ifdef i386}
  46.        ,i386
  47.        ,rai386
  48.        ,ratti386
  49.        ,radi386
  50.        ,tgeni386
  51. {$endif}
  52. {$ifdef m68k}
  53.        ,m68k
  54.        ,tgen68k
  55.        ,ag68kmit
  56.        ,ra68k
  57.        ,ag68kgas
  58.        ,ag68kmot
  59. {$endif}
  60.        { parser specific stuff, be careful consume is also defined to }
  61.        { read assembler tokens                                        }
  62.        ,pbase,pexpr,pdecl;
  63.  
  64.  
  65.     function statement : ptree;forward;
  66.  
  67.     function if_statement : ptree;
  68.  
  69.       var
  70.          ex,if_a,else_a : ptree;
  71.  
  72.       begin
  73.          consume(_IF);
  74.          ex:=expr;
  75.          consume(_THEN);
  76.          if token<>_ELSE then
  77.            if_a:=statement
  78.          else
  79.        if_a:=nil;
  80.  
  81.          if token=_ELSE then
  82.            begin
  83.               consume(_ELSE);
  84.               else_a:=statement;
  85.            end
  86.          else
  87.            else_a:=nil;
  88.          if_statement:=genloopnode(ifn,ex,if_a,else_a,false);
  89.       end;
  90.  
  91.     { creates a block (list) of statements, til the next END token }
  92.     function statements_til_end : ptree;
  93.  
  94.       var
  95.          first,last : ptree;
  96.  
  97.       begin
  98.          first:=nil;
  99.          while token<>_END do
  100.            begin
  101.               if first=nil then
  102.                 begin
  103.                    last:=gennode(anwein,nil,statement);
  104.                    first:=last;
  105.                 end
  106.               else
  107.                 begin
  108.                    last^.left:=gennode(anwein,nil,statement);
  109.                    last:=last^.left;
  110.                 end;
  111.               if token<>SEMICOLON then
  112.                 break
  113.               else
  114.                 consume(SEMICOLON);
  115.               while token=SEMICOLON do
  116.                 consume(SEMICOLON);
  117.  
  118.            end;
  119.          consume(_END);
  120.          statements_til_end:=gensinglenode(blockn,first);
  121.       end;
  122.  
  123.     function case_statement : ptree;
  124.  
  125.       var
  126.          { contains the label number of currently parsed case block }
  127.          aktcaselabel : plabel;
  128.          wurzel : pcaserecord;
  129.  
  130.          { the typ of the case expression }
  131.          casedef : pdef;
  132.  
  133.       procedure newcaselabel(l,h : longint);
  134.  
  135.         var
  136.            hcaselabel : pcaserecord;
  137.  
  138.         procedure insertlabel(var p : pcaserecord);
  139.  
  140.           begin
  141.              if p=nil then p:=hcaselabel
  142.              else
  143.                 if (p^._low>hcaselabel^._low) and
  144.                    (p^._low>hcaselabel^._high) then
  145.                   insertlabel(p^.less)
  146.                 else if (p^._high<hcaselabel^._low) and
  147.                    (p^._high<hcaselabel^._high) then
  148.                   insertlabel(p^.greater)
  149.                 else Message(parser_e_double_caselabel);
  150.           end;
  151.  
  152.         begin
  153.            new(hcaselabel);
  154.            hcaselabel^.less:=nil;
  155.            hcaselabel^.greater:=nil;
  156.            hcaselabel^.statement:=aktcaselabel;
  157.            getlabel(hcaselabel^._at);
  158.            hcaselabel^._low:=l;
  159.            hcaselabel^._high:=h;
  160.            insertlabel(wurzel);
  161.         end;
  162.  
  163.       var
  164.          code,caseexpr,p,instruc,elseblock : ptree;
  165.          hl1,hl2 : longint;
  166.          ranges : boolean;
  167.  
  168.       begin
  169.          consume(_CASE);
  170.          caseexpr:=expr;
  171.          { determines result type }
  172.          cleartempgen;
  173.          do_firstpass(caseexpr);
  174.          casedef:=caseexpr^.resulttype;
  175.  
  176.          if not(is_ordinal(casedef)) then
  177.            Message(parser_e_ordinal_expected);
  178.  
  179.          consume(_OF);
  180.          wurzel:=nil;
  181.          ranges:=false;
  182.          instruc:=nil;
  183.          repeat
  184.            getlabel(aktcaselabel);
  185.            {aktcaselabel^.is_used:=true; }
  186.  
  187.            { an instruction has may be more case labels }
  188.            repeat
  189.              p:=expr;
  190.              cleartempgen;
  191.              do_firstpass(p);
  192.  
  193.              if (p^.treetype=rangen) then
  194.                begin
  195.                   { type checking for case statements }
  196.                   if not is_subequal(casedef, p^.left^.resulttype) then
  197.                     Message(parser_e_case_mismatch);
  198.                   { type checking for case statements }
  199.                   if not is_subequal(casedef, p^.right^.resulttype) then
  200.                     Message(parser_e_case_mismatch);
  201.                   hl1:=get_ordinal_value(p^.left);
  202.                   hl2:=get_ordinal_value(p^.right);
  203.                   testrange(casedef,hl1);
  204.                   testrange(casedef,hl2);
  205.                   newcaselabel(hl1,hl2);
  206.                   ranges:=true;
  207.                end
  208.              else
  209.                begin
  210.                   { type checking for case statements }
  211.                   if not is_subequal(casedef, p^.resulttype) then
  212.                     Message(parser_e_case_mismatch);
  213.                     hl1:=get_ordinal_value(p);
  214.                     testrange(casedef,hl1);
  215.                     newcaselabel(hl1,hl1);
  216.                end;
  217.              disposetree(p);
  218.              if token=COMMA then consume(COMMA)
  219.                else break;
  220.            until false;
  221.            consume(COLON);
  222.  
  223.            { handles instruction block }
  224.            p:=gensinglenode(labeln,statement);
  225.            p^.labelnr:=aktcaselabel;
  226.  
  227.            { concats instruction }
  228.            instruc:=gennode(anwein,instruc,p);
  229.  
  230.            if not((token=_ELSE) or (token=_OTHERWISE) or (token=_END)) then
  231.              consume(SEMICOLON);
  232.          until (token=_ELSE) or (token=_OTHERWISE) or (token=_END);
  233.  
  234.          if (token=_ELSE) or (token=_OTHERWISE) then
  235.            begin
  236.               if token=_ELSE then consume(_ELSE)
  237.                 else consume(_OTHERWISE);
  238.               elseblock:=statements_til_end;
  239.            end
  240.          else
  241.            begin
  242.               elseblock:=nil;
  243.               consume(_END);
  244.            end;
  245.  
  246.          code:=gencasenode(caseexpr,instruc,wurzel);
  247.  
  248.          code^.elseblock:=elseblock;
  249.  
  250.          case_statement:=code;
  251.       end;
  252.  
  253.     function repeat_statement : ptree;
  254.  
  255.       var
  256.          first,last,p_e : ptree;
  257.  
  258.       begin
  259.          consume(_REPEAT);
  260.          first:=nil;
  261.          while token<>_UNTIL do
  262.            begin
  263.               if first=nil then
  264.                 begin
  265.                    last:=gennode(anwein,nil,statement);
  266.                    first:=last;
  267.                 end
  268.               else
  269.                 begin
  270.                    last^.left:=gennode(anwein,nil,statement);
  271.                    last:=last^.left;
  272.                 end;
  273.               if token<>SEMICOLON then
  274.                 break;
  275.               consume(SEMICOLON);
  276.               while token=SEMICOLON do
  277.                 consume(SEMICOLON);
  278.            end;
  279.          consume(_UNTIL);
  280.          first:=gensinglenode(blockn,first);
  281.          p_e:=expr;
  282.          repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
  283.       end;
  284.  
  285.     function while_statement : ptree;
  286.  
  287.       var
  288.          p_e,p_a : ptree;
  289.  
  290.       begin
  291.          consume(_WHILE);
  292.      p_e:=expr;
  293.          consume(_DO);
  294.          p_a:=statement;
  295.          while_statement